Option Public
Option Explicit

%REM
	Function ExtractOneAttachmentToFile
	Description: Comments for Function
%END REM
Function ExtractOneAttachmentToFilePath(doc As NotesDocument, strAttachmentName As String, strToFilePath As String)As Boolean
	'/**
	' * 方法简介
	' * 
	' * @param 参数名 参数说明
	' * @return 返回类型 返回说明
	' * @depends
	' * @see
	' * @error
	' * @version 1.0
	' * @author
	' */
try:
	'set up error handler
	On Error GoTo catch	
	ExtractOneAttachmentToFilePath = False
	
	'变量定义
	Dim o As Variant
	'变量初始化
	
	
	
	If Not doc Is Nothing Then
		Set o = doc.Getattachment(strAttachmentName)
		
		If isFile(strToFilePath) Then'路过文件已存在则删除
			
		End If
		
		Call o.ExtractFile( strToFilePath )				

	End If
	
	ExtractOneAttachmentToFilePath = True
	GoTo finally
catch:
	'log error
	'Msgbox Erl & ":" & Error
	MsgBox LSI_Info(2) & " called by " & LSI_Info(12) & "(" & LSI_Info(430) & "): " & Error$ & " - Line: " & CStr(Erl)
	'resume to the final thing
	Resume finally
	
finally:
	'do the final thing
	Exit Function	
End Function
Function isFile(Byval sFileName As String) As Boolean
%REM
判定是否文件
%END REM
	On Error Resume Next
	Dim lFileLength As Long
	Const ATTR_NORMAL = 0
	
	isFile = False
	If Dir$(sFileName, ATTR_NORMAL) <> "" Then
		lFileLength = Filelen(sFileName)
		If (lFileLength > 0) Then isFile = True
	End If
End Function 
%REM
附加的文件至文档
%END REM
Function AppendFileToDoc(doc As NotesDocument, strFieldName As String, strFileName As String) As Boolean
'/**
' * 方法简介
' * 
' * @param 参数名 参数说明
' * @return 返回类型 返回说明
' * @depends
' * @see
' * @error
' * @version 1.0
' * @author
' */
try:
	'set up error handler
	On Error GoTo catch
	AppendFileToDoc = False
	
	'变量定义
	Dim rtmO2FJ As NotesRichTextItem'附件附加域
	Dim object As Variant
	
	'变量初始化
	Set rtmO2FJ =  doc.GetFirstItem(strFieldName)
	
	If Not rtmO2FJ Is Nothing Then
%REM
		Forall o In rtmO2FJ.EmbeddedObjects
			If ( o.Type = EMBED_ATTACHMENT ) Then
				Call o.Remove
			End If
		End Forall
%ENDREM
		doc.RemoveItem(strFieldName)
	'Else
		
	End If
	
	Set rtmO2FJ = doc.CreateRichTextItem(strFieldName)
	
	If isFile(strFileName) Then
		
		Set object = rtmO2FJ.EmbedObject( EMBED_ATTACHMENT, "", strFileName)					
		
	End If
	
	
	
	AppendFileToDoc = True
	GoTo finally
catch:
	'log error
	'Msgbox Erl & ":" & Error
	MsgBox LSI_Info(2) & " called by " & LSI_Info(12) & "(" & LSI_Info(430) & "): " & Error$ & " - Line: " & CStr(Erl)
	'resume to the final thing
	Resume finally
	
finally:
	'do the final thing
	Exit Function
End Function
Function isFolder(Byval sFolderPath As String) As Boolean
%REM
判定是否文件夹
%END REM
	On Error Resume Next
	Const ATTR_DIRECTORY = 16
	isFolder = False
	If Dir$(sFolderPath, ATTR_DIRECTORY) <> "" Then isFolder = True
End Function 
Function validatefilename(filename As String)
	Dim l As Integer
	Dim x As Integer
	Dim newname As String
	l=Len(filename)
	For x = 1 To l
		If Mid$(filename,x,1) Like "[-@()~^$#[{}=A-Za-z0-9]" Then
			newname=newname+Mid$(filename,x,1)
		Else
			If Mid$(filename,x,1)=" " Or Mid$(filename,x,1)="]" Or Mid$(filename,x,1)=","  Or Mid$(filename,x,1)="'"  Or Mid$(filename,x,1)="!" Then
				newname=newname+Mid$(filename,x,1)
			Else
				Print Mid$(filename,x,1) " is not valid"
			End If
			
		End If
	Next x
	validatefilename=newname
End Function
Function GetDataFolder()As String
'/**
' * 方法简介
' * 
' * @param 参数名 参数说明
' * @return 返回类型 返回说明
' * @depends
' * @see
' * @error
' * @version 1.0
' * @author
' */
try:
	'set up error handler
	On Error GoTo catch	
	
	GetDataFolder = ""
	
	Dim s As New NotesSession
	Dim strFolder As String
	
	strFolder = "" & s.GetEnvironmentString("Directory",True )
	GetDataFolder = strFolder
	
	GoTo finally
catch:
	'log error
	'Msgbox Erl & ":" & Error
	MsgBox LSI_Info(2) & " called by " & LSI_Info(12) & "(" & LSI_Info(430) & "): " & Error$ & " - Line: " & CStr(Erl)
	'resume to the final thing
	Resume finally
	
finally:
	'do the final thing
	Exit Function
End Function
%REM
	Function getFileExt
	Description: Comments for Function
%END REM
Function getFileExt(strFileName As string)As string
	getFileExt = StrRightBack(strFileName, ".")
End Function
%REM
	Function ExtractOneAttachmentToFile
	Description: Comments for Function
%END REM
Function ExtractOneAttachmentToFile(doc As NotesDocument, strAttachmentName As String, strToFolder As String, strToFileName As string)As boolean
	'/**
	' * 方法简介
	' * 
	' * @param 参数名 参数说明
	' * @return 返回类型 返回说明
	' * @depends
	' * @see
	' * @error
	' * @version 1.0
	' * @author
	' */
try:
	'set up error handler
	On Error GoTo catch	
	ExtractOneAttachmentToFile = false
	
	'变量定义
	Dim strFilePath As string
	Dim o As Variant
	'变量初始化
	
	
	If Not isFolder(strToFolder) Then
		MkDir (strToFolder)
	End If
	
	If Not doc Is Nothing Then
		Set o = doc.Getattachment(strAttachmentName)

		strFilePath = strToFolder + strToFileName
		
		If isFile(strFilePath) Then'路过文件已存在则删除
			
		End If
		
		Call o.ExtractFile( strFilePath )				

	End If
	
	ExtractOneAttachmentToFile = true
	GoTo finally
catch:
	'log error
	'Msgbox Erl & ":" & Error
	MsgBox LSI_Info(2) & " called by " & LSI_Info(12) & "(" & LSI_Info(430) & "): " & Error$ & " - Line: " & CStr(Erl)
	'resume to the final thing
	Resume finally
	
finally:
	'do the final thing
	Exit Function	
End Function
Function GetDominoFolder()As String
'/**
' * 方法简介
' * 
' * @param 参数名 参数说明
' * @return 返回类型 返回说明
' * @depends
' * @see
' * @error
' * @version 1.0
' * @author
' */
try:
	'set up error handler
	On Error GoTo catch	
	
	GetDominoFolder = ""
	
	Dim s As New NotesSession
	Dim strFolder As String
	
	strFolder = "" & s.GetEnvironmentString("NotesProgram",True )
	GetDominoFolder = strFolder
	
	GoTo finally
catch:
	'log error
	'Msgbox Erl & ":" & Error
	MsgBox LSI_Info(2) & " called by " & LSI_Info(12) & "(" & LSI_Info(430) & "): " & Error$ & " - Line: " & CStr(Erl)
	'resume to the final thing
	Resume finally
	
finally:
	'do the final thing
	Exit Function
End Function
%REM
  Function MakeDir
  Description: Create a directory with the specified path. Parent directories are also created, if
    they don't exist.
%END REM
Sub MakeDir(ByVal strDir$)
  Dim stack$ ' the list of directories we need to create
  Dim parts, i%, ptr%
 
  strDir = Replace(strDir, "\", "/") ' / works on all OS and simplifies our code.
  strDir = Replace(strDir, "//", "/")
  If Right$(strDir, 1) = "/" Then strDir = StrLeftBack(strDir, "/")
  On Error 76 GoTo parentDoesNotExist
  MkDir strDir
  ' if we got here, it worked.
  Exit Sub
 
parentDoesNotExist: ' failed because parent directory doesn't exist. Build an array of directories to attempt.
  Resume theLoop
   
theLoop:
  parts = Split(strDir, "/")
  For i = 1 To UBound(parts)
    parts(i) = parts(i-1) & "/" & parts(i)
  Next
  ptr = UBound(parts) - 1 ' ptr is index of directory to try to create.
  On Error 76 GoTo backup
tryAnother:
  MkDir parts(ptr)
  ' if we get here the create succeeded, and we only have to go forward in the list.
  On Error GoTo 0
  For i = ptr+1 To UBound(parts)
    MkDir parts(i)
  Next
  Exit Sub
   
backup:
  ptr = ptr - 1
  If ptr >= 0 Then
    If parts(ptr) = "" Then GoTo backup
    Resume tryAnother
  End If
  Error Err, Error ' ran out of higher level directories to try.
End Sub